home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / scheme48.init < prev    next >
Text File  |  1999-04-19  |  8KB  |  275 lines
  1. ;;;"scheme48.init" Initialisation for SLIB for Scheme48    -*-scheme-*-
  2. ;;; Author: Aubrey Jaffer
  3. ;;;
  4. ;;; This code is in the public domain.
  5.  
  6. ;;; If you know the magic incantation to make a "," command available
  7. ;;; as a scheme procedure, you can make a nifty slib function to do
  8. ;;; this (like `slib:dump' in "vscm.init").  But for now, type:
  9. ;;;    make slib48
  10.  
  11. ;;; (software-type) should be set to the generic operating system type.
  12. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
  13.  
  14. (define (software-type) 'UNIX)
  15.  
  16. ;;; (scheme-implementation-type) should return the name of the scheme
  17. ;;; implementation loading this file.
  18.  
  19. (define (scheme-implementation-type) 'Scheme48)
  20.  
  21. ;;; (scheme-implementation-home-page) should return a (string) URL
  22. ;;; (Uniform Resource Locator) for this scheme implementation's home
  23. ;;; page; or false if there isn't one.
  24.  
  25. (define (scheme-implementation-home-page)
  26.   "http://www.neci.nj.nec.com/homepages/kelsey.html")
  27.  
  28. ;;; (scheme-implementation-version) should return a string describing
  29. ;;; the version of the scheme implementation loading this file.
  30.  
  31. (define scheme-implementation-version
  32.   (cond ((= -86400 (modulo -2177452800 -86400))
  33.      (display "scheme48-0.36 has been superseded by")
  34.      (newline)
  35.      (display "ftp@swissnet.ai.mit.edu:pub/s48/scheme48-0.46.tgz")
  36.      (newline)
  37.      (display "ftp://swissnet.ai.mit.edu/pub/s48/scheme48-0.46.tgz")
  38.      (newline)
  39.      (lambda () "0.36"))
  40.     (else (lambda () "0.46"))))
  41.  
  42. ;;; (implementation-vicinity) should be defined to be the pathname of
  43. ;;; the directory where any auxiliary files to your Scheme
  44. ;;; implementation reside.
  45.  
  46. ;;; [ defined from the Makefile ]
  47.  
  48. ;;; (library-vicinity) should be defined to be the pathname of the
  49. ;;; directory where files of Scheme library functions reside.
  50.  
  51. ;;; [ defined from the Makefile ]
  52.  
  53. (define getenv s48-getenv)
  54. (define system s48-system)
  55.  
  56. ;;; (home-vicinity) should return the vicinity of the user's HOME
  57. ;;; directory, the directory which typically contains files which
  58. ;;; customize a computer environment for a user.
  59.  
  60. (define home-vicinity
  61.   (let ((home-path (getenv "HOME")))
  62.     (lambda () home-path)))
  63.  
  64. ;;; *FEATURES* should be set to a list of symbols describing features
  65. ;;; of this implementation.  See Template.scm for the list of feature
  66. ;;; names.
  67.  
  68. (define *features*
  69.       '(
  70.     source                ;can load scheme source files
  71.                     ;(slib:load-source "filename")
  72. ;    compiled            ;can load compiled files
  73.                     ;(slib:load-compiled "filename")
  74.     rev4-report            ;conforms to
  75.     ieee-p1178            ;conforms to
  76.     rev4-optional-procedures
  77.     multiarg/and-
  78.     multiarg-apply
  79.     rationalize
  80.     delay                ;has delay and force
  81.     with-file
  82.     char-ready?            ;has
  83.     eval                ;proposed 2-argument eval
  84.     values                ;proposed multiple values
  85.     dynamic-wind            ;proposed dynamic-wind
  86.     full-continuation        ;can return multiple times
  87.     macro                ;R4RS appendix's DEFINE-SYNTAX
  88.     system                ;posix (system <string>)
  89.     getenv                ;posix (getenv <string>)
  90.     ))
  91.  
  92. ;;; (OUTPUT-PORT-WIDTH <port>)
  93. (define (output-port-width . arg) 79)
  94.  
  95. ;;; (OUTPUT-PORT-HEIGHT <port>)
  96. (define (output-port-height . arg) 24)
  97.  
  98. ;;; (CURRENT-ERROR-PORT)
  99. (define current-error-port s48-current-error-port)
  100.  
  101. ;;; (TMPNAM) makes a temporary file name.
  102. (define tmpnam
  103.   (let ((cntr 100))
  104.     (lambda () (set! cntr (+ 1 cntr))
  105.         (let ((tmp (string-append "slib_" (number->string cntr))))
  106.           (if (file-exists? tmp) (tmpnam) tmp)))))
  107.  
  108. ;;; (FILE-EXISTS? <string>)
  109. (define (file-exists? f)
  110.   (call-with-current-continuation
  111.    (lambda (k)
  112.      (s48-with-handler
  113.       (lambda (condition decline)
  114.     (k #f))
  115.       (lambda ()
  116.     (close-input-port (open-input-file f))
  117.     #t)))))
  118.  
  119. ;;; (DELETE-FILE <string>)
  120. (define (delete-file file-name)
  121.   (s48-system (string-append "rm " file-name)))
  122.  
  123. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
  124. ;;; use this definition if your system doesn't have such a procedure.
  125. (define (force-output . arg)
  126.   (s48-force-output
  127.    (if (null? arg) (current-output-port) (car arg))))
  128.  
  129. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  130. ;;; be returned by CHAR->INTEGER.
  131. (define integer->char s48-ascii->char)
  132. (define char->integer
  133.   (let ((char->integer char->integer)
  134.     (code0 (char->integer (integer->char 0))))
  135.     (lambda (char) (- (char->integer char) code0))))
  136. (define char-code-limit 256)
  137.  
  138. ;;; Workaround MODULO bug
  139. (define modulo
  140.   (let ((modulo modulo))
  141.     (lambda (n1 n2)
  142.       (let ((ans (modulo n1 n2)))
  143.     (if (= ans n2) (- ans ans) ans)))))
  144.  
  145. ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
  146. (define most-positive-fixnum #x1FFFFFFF)
  147.  
  148. ;;; Return argument
  149. (define (identity x) x)
  150.  
  151. ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
  152. (define slib:eval
  153.   (let ((eval eval)
  154.     (interaction-environment interaction-environment))
  155.     (lambda (form)
  156.       (eval form (interaction-environment)))))
  157.  
  158. ;;; If your implementation provides R4RS macros:
  159. (define macro:eval slib:eval)
  160. (define (macro:load <pathname>)
  161.   (if (not (file-exists? <pathname>))
  162.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  163.   (load <pathname>))
  164.  
  165. (define *defmacros*
  166.   (list (cons 'defmacro
  167.           (lambda (name parms . body)
  168.         `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body))
  169.                       *defmacros*))))))
  170. (define (defmacro? m) (and (assq m *defmacros*) #t))
  171.  
  172. (define (macroexpand-1 e)
  173.   (if (pair? e) (let ((a (car e)))
  174.           (cond ((symbol? a) (set! a (assq a *defmacros*))
  175.                      (if a (apply (cdr a) (cdr e)) e))
  176.             (else e)))
  177.       e))
  178.  
  179. (define (macroexpand e)
  180.   (if (pair? e) (let ((a (car e)))
  181.           (cond ((symbol? a)
  182.              (set! a (assq a *defmacros*))
  183.              (if a (macroexpand (apply (cdr a) (cdr e))) e))
  184.             (else e)))
  185.       e))
  186.  
  187. (define gentemp
  188.   (let ((*gensym-counter* -1))
  189.     (lambda ()
  190.       (set! *gensym-counter* (+ *gensym-counter* 1))
  191.       (string->symbol
  192.        (string-append "slib:G" (number->string *gensym-counter*))))))
  193.  
  194. (define base:eval slib:eval)
  195. (define (defmacro:eval x) (base:eval (defmacro:expand* x)))
  196. (define (defmacro:expand* x)
  197.   (require 'defmacroexpand) (apply defmacro:expand* x '()))
  198.  
  199. (define (defmacro:load <pathname>)
  200.   (slib:eval-load <pathname> defmacro:eval))
  201.  
  202. (define (slib:eval-load <pathname> evl)
  203.   (if (not (file-exists? <pathname>))
  204.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  205.   (call-with-input-file <pathname>
  206.     (lambda (port)
  207.       (let ((old-load-pathname *load-pathname*))
  208.     (set! *load-pathname* <pathname>)
  209.     (do ((o (read port) (read port)))
  210.         ((eof-object? o))
  211.       (evl o))
  212.     (set! *load-pathname* old-load-pathname)))))
  213.  
  214. (define slib:warn
  215.   (lambda args
  216.     (let ((port (current-error-port)))
  217.       (display "Warn: " port)
  218.       (for-each (lambda (x) (display x port)) args))))
  219.  
  220. ;;; define an error procedure for the library
  221. (define slib:error s48-error)
  222.  
  223. ;;; define these as appropriate for your system.
  224. (define slib:tab (s48-ascii->char 9))
  225. (define slib:form-feed (s48-ascii->char 12))
  226.  
  227. ;;; Support for older versions of Scheme.  Not enough code for its own file.
  228. (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
  229. (define t #t)
  230. (define nil #f)
  231.  
  232. ;;; Define these if your implementation's syntax can support them and if
  233. ;;; they are not already defined.
  234.  
  235. (define (1+ n) (+ n 1))
  236. (define (-1+ n) (+ n -1))
  237. ;(define 1- -1+)
  238.  
  239. (define in-vicinity string-append)
  240.  
  241. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  242. ;;; return if exitting not supported.
  243. (define slib:exit (lambda args #f))
  244.  
  245. ;;; Here for backward compatability
  246. (define scheme-file-suffix
  247.   (case (software-type)
  248.     ((NOSVE) (lambda () "_scm"))
  249.     (else (lambda () ".scm"))))
  250.  
  251. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  252. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  253.  
  254. (define (slib:load-source f) (load (string-append f (scheme-file-suffix))))
  255.  
  256. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  257. ;;; by compiling "foo.scm" if this implementation can compile files.
  258. ;;; See feature 'COMPILED.
  259.  
  260. (define slib:load-compiled load)
  261.  
  262. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  263.  
  264. (define slib:load slib:load-source)
  265.  
  266. ;;; Scheme48 complains that these are not defined (even though they
  267. ;;; won't be called until they are).
  268. (define synclo:load #f)
  269. (define syncase:load #f)
  270. (define macwork:load #f)
  271. (define transcript-on #f)
  272. (define transcript-off #f)
  273.  
  274. (slib:load (in-vicinity (library-vicinity) "require"))
  275.